CD ROM Paradise Collection 4/CD ROM Paradise Collection 4 1995 Nov.iso/program/pcfig4th.zip/STUFF.SCR

Text File | 1985-02-04 | 15KB | 1 lines

( utilities: printing: FINEPRINT, 2UP )                         FORTH DEFINITIONS DECIMAL ( for Epson MX series printers )      : ESC     27 EMIT ;                                             : FINEPRINT  1 PRINTER !  ESC 70 EMIT ( no emphasized mode! )         15 EMIT ESC 48 EMIT ( SO ESC "0" = condensed, 8 l/in )          ESC 67 88 EMIT EMIT ( 88 l/page ) 0 PRINTER ! CLS ;       : 64LINE  (LINE) DROP 64 TYPE ;                                 : FILLS   0 DO 61 EMIT LOOP ;                                   : HEAD    24 FILLS SPACE SPACE ." Screen  "                               0 <# # # # # #> TYPE SPACE SPACE 24 FILLS ;           : 2UP ( scr1 scr2 --    print 2 screens/page )                        SWAP  2DUP CR 3 SPACES HEAD SPACE HEAD CR                       16 0 DO  2DUP                                                     I 2 .R SPACE  I SWAP 64LINE  SPACE I SWAP .LINE CR            LOOP DROP DROP ;                                          ;S                                                              ( utilities: disc copy primitives  )                            FORTH DEFINITIONS                                               320 CONSTANT MAXREC                                             : PAUSE ." hit any key to continue..." KEY DROP ;               : FILL   ( n -- ; load up all the buffers, starting at block n)      #BUFF OVER + SWAP   ( marking them to be flushed to DR1 )       DO                                                                 I MAXREC > 0=                                                   IF  I MAXREC + I BLOCK 2- ! UPDATE                              ELSE LEAVE ENDIF                                             LOOP ;                                                     : BLOCK0  ( -- ; kludge to access BLOCK 0 )                          FIRST LIMIT OVER - BLANKS ;                                : NL CR 0 OUT ! ." Block" ;  : NL?  OUT @ 70 > IF NL THEN ;     : DISPLAY  NL? 7 .R ;                                           -->                                                             ( utilities: DISKCOPY  )                                        : DISKCOPY  ( -- ; copies DR0 to DR1, regardless of content )        CR ." Place source disk in drive A, destination disk in "          ." drive B." CR ." ANY FILES ON THE DESTINATION DISK "          ." WILL BE LOST !!" CR PAUSE ." please wait" CR              FLUSH DR0 0 DRIVE ! BLOCK0                                      MAXREC 0                                                        DO                                                                 I DISPLAY I FILL FLUSH                                       #BUFF +LOOP                                                     CR CR ." Disk copy finished.   " ;                         ;S                                                              ( note: this takes about 10 minutes with only 4 buffers ! )                                                                                                                                                                                                     ( TRIG LOOKUP ROUTINES WITH SINE * 10000 TABLE )                : TABLE ( ... N -> , CREATE 'TABLE' DATA TYPE  )                  <BUILDS 0 DO , LOOP   ( COMPILE N ELEMENTS )                    DOES> SWAP 2 * + @    ( EXECUTE TABLE LOOKUP )                ;                                                               10000 9998 9994 9986 9976 9962 9945 9925 9903 9877               9848 9816 9781 9744 9703 9659 9613 9563 9511 9455               9397 9336 9272 9205 9135 9063 8988 8910 8829 8746               8660 8572 8480 8387 8290 8192 8090 7986 7880 7771               7660 7547 7431 7314 7193 7071 6947 6820 6691 6561               6428 6293 6157 6018 5878 5736 5592 5446 5299 5150               5000 4848 4695 4540 4384 4226 4067 3907 3746 3584               3420 3256 3090 2924 2756 2588 2419 2250 2079 1908               1736 1564 1391 1219 1045 0872 0698 0523 0349 0175               0000 ( 91 ELEMENTS OF TABLE PLACED ON STACK )                   91 TABLE SINTABLE -->                                          ( TRIG TABLE LOOKUP ROUTINES, CONTINUED )                       : S180 ( N -> N  RETURNS SINE 0-180 DEGREES )                     DUP 90 >   ( IF GREATER THAN 90 DEGREES )                       IF 180 SWAP - ENDIF ( SUBTRACT FROM 180 )                       SINTABLE ( THEN TAKE SINE )                                   ;                                                               : SIN  ( N -> SINE  RETURN SINE OF ANY NO. OF DEGREES )           360 MOD   ( BRING WITHIN + OR - 360 )                           DUP 0< IF 360 + ENDIF ( IF NEGATIVE, ADD 360 )                  DUP 180 >  ( TEST IF GREATER THAN 180 )                         IF 180 - S180 MINUS ( IF SO, SUBTRACT 180, NEGATE SINE )        ELSE S180 ENDIF ( OTHERWISE, STRAIGHTFORWARD )                ;                                                               : COS  ( N -> COSINE )                                            360 MOD ( PREVENT OVERFLOW NEAR 32767 )                         90 + SIN ; ( COS IS SIN WITH 90 DEG PHASE SHIFT )             ( THE GAME OF LIFE, ADAPTED FROM DAVE BOULTON )                 ( FORTH DIMENSIONS III/5 PAGE 24 )                              FORTH DEFINITIONS DECIMAL : TASK ; 8 LOAD                       DECIMAL 39 CONSTANT XLEN 22 CONSTANT YLEN                       XLEN YLEN 2ARRAY UNIVERSE 0 VARIABLE #GENERATION                : J RP@ 6 + @ ;                                                 : CHECK DUP 3 = IF DROP 2+ ELSE 2 = 0=                            IF 4 + ENDIF ENDIF ;                                          : CLEAR  YLEN 0 DO XLEN 0 DO I J UNIVERSE                         0 SWAP C! LOOP LOOP ;                                         : DISPLAY CLS ." Generation " #GENERATION @ .                     YLEN 0 DO XLEN 0 DO                                             I J UNIVERSE C@   IF I 2 * J GOTOXY 42 EMIT ENDIF               LOOP LOOP HOME ;                                              -->                                                                                                                             ( THE GAME OF LIFE, CONTINUED )                                 : X-      1 - DUP 0 < IF DROP XLEN 1 - ENDIF ;                  : X+      1 + DUP XLEN = IF DROP 0 ENDIF ;                      : Y-      1 - DUP 0 < IF DROP YLEN 1 - ENDIF ;                  : Y+      1 + DUP YLEN = IF DROP 0 ENDIF ;                      : CELL C@ 1 AND + ;                                             : GENERATE                                                        YLEN 0 DO XLEN 0 DO  0                                          I X- J UNIVERSE CELL I X+ J  UNIVERSE CELL                      I X- J Y+ UNIVERSE CELL I J Y+ UNIVERSE CELL                    I X+ J Y+ UNIVERSE CELL  I X- J Y- UNIVERSE CELL                I J Y- UNIVERSE CELL  I X+ J Y- UNIVERSE CELL                   I J UNIVERSE C@   1 AND SWAP CHECK   I J UNIVERSE C!            LOOP LOOP ;                                                   -->                                                                                                                             ( THE GAME OF LIFE, CONTINUED )                                 0 VARIABLE CUR 0 VARIABLE SETUPFLAG                             : .CUR CUR @ XLEN /MOD SWAP DUP + SWAP GOTOXY ;    : !CUR 0     MAX YLEN XLEN * 1 - MIN CUR ! ;   : +CUR CUR @ + !CUR ;         : +.CUR +CUR .CUR ; : +LIN CUR @ XLEN / + XLEN * !CUR ;         HEX 1B CONSTANT EXITFLAG 50 CONSTANT DOWNCURSOR                 0D CONSTANT NEWLINE 08 CONSTANT BACKCURSOR DECIMAL              : SETUPLIFE CLS ." Enter starting pattern     "                 ."            push <ESC> when finished " CR                     0 SETUPFLAG ! 0 CUR ! .CUR BEGIN KEY CASE EXITFLAG OF 1         SETUPFLAG ! ENDOF DOWNCURSOR OF XLEN +.CUR ENDOF                BACKCURSOR OF -1 +.CUR ENDOF NEWLINE OF 1 +LIN .CUR ENDOF       32 OF 32 EMIT 0 CUR @ XLEN /MOD UNIVERSE C! 1 +.CUR ENDOF       42 OF 42 EMIT 1 CUR @ XLEN /MOD UNIVERSE C! 1 +.CUR ENDOF       ENDCASE SETUPFLAG @ UNTIL ;                                     -->                                                             ( THE GAME OF LIFE, CONTINUED )                                 : NORMALIZE YLEN 0 DO XLEN 0 DO                                   I J UNIVERSE DUP C@ DUP                                         4 AND IF DROP 0 ELSE 3 AND IF 1 ELSE 0 ENDIF ENDIF              SWAP C!                                                         LOOP LOOP ;                                                   : GENERATIONS 1 #GENERATION ! CLEAR SETUPLIFE                     0 DO DISPLAY GENERATE                                           NORMALIZE 1 #GENERATION +! LOOP                                 DISPLAY XLEN YLEN GOTOXY ;                                                                                                    ." Type 'n GENERATIONS <CR>' to play" ;S                                                                                                                                                                                                                                                                                        ( math: RANDOM  )                                               ( RANDOM NUMBER GENERATOR, J. E. Rickenbacker )                 ( FORTH DIMENSIONS II/2 PAGE 34               )                                                                                 FORTH DEFINITIONS DECIMAL                                                                                                       0 VARIABLE SEED                                                                                                                 : (RAND) SEED @ 259 * 3 + 32767 AND DUP SEED ! ;                                                                                 ( n -- r  : select a random # r, 0<= r < n )                   : RANDOM (RAND) 32767 */ ;                                                                                                                                                                                                                                                                                                      ( utilities: TIME? DATE? ET0 T-)                                FORTH DEFINITIONS DECIMAL                                       : ##        0 <# # # #> TYPE ;                                  : DATE?    DATE@ ## 47 EMIT ## 47 EMIT ## SPACE ;                                                                               0 VARIABLE [T] 2 ALLOT  0 VARIABLE [ET] 2 ALLOT                 : T>       [T] 2! [T] 2+ C@ ( csec ) [T] 3 + C@ ( sec )                           [T]    C@ ( min  ) [T] 1+  C@ ( hr  ) ;       : >T       [T] 1+  C! ( hr  ) [T] C! ( min )                               [T] 3 + C! ( sec ) [T] 2+ C! ( csec ) [T] 2@ ;       : -MOD100    - DUP 0< IF 100 + -1 ELSE 0 THEN ;                 : -MOD60     - DUP 0< IF 60  + -1 ELSE 0 THEN ;                 : -MOD24     - DUP 0< IF 24  + -1 ELSE 0 THEN ;                 : .T       ## 58 EMIT ## 58 EMIT ## 46 EMIT ## SPACE ;          : TIME?    TIME@ T> .T ;                                        -->                                                             ( time utilities: ET ET? )                                      0 VARIABLE [T0] 2 ALLOT     0 VARIABLE [T1] 2 ALLOT             : T-     [T0] 2!  [T1] 2!                                                [T1] 2+  C@   [T0] 2+  C@  -MOD100  ( delta csec )              [T1] 3 + C@ + [T0] 3 + C@  -MOD60   ( delta sec )               [T1]     C@ + [T0]     C@  -MOD60   ( delta min )               [T1] 1+  C@ + [T0] 1+  C@  -MOD24   ( delta hr ) ;     : ET0    TIME@ [ET] 2! ;    ( reset elapsed time )              : ET     TIME@ [ET] 2@ T- ; ( measure elapsed time )            : ET?    ET DROP .T ;                                           : >CS    60 * +  60 * +  100 * + ;                              : ET(S)  ET DROP >CS  0 <# # # 46 HOLD # # #> TYPE SPACE ;      ;S                                                                                                                                                                                                                                                              ( math: fixed point SQRT )                                      FORTH DEFINITIONS DECIMAL                                       : 2DROP   DROP DROP ;                                           : 2*      DUP + ;      : D2*    2DUP D+ ;                       : D<      ROT 2DUP = IF ROT ROT DMINUS D+ 0<                              ELSE  SWAP < SWAP DROP THEN  SWAP DROP ;              : DU<     32768 + ROT 32768 + ROT ROT D< ;                                                                                      : EBITS   0 DO  >R D2* D2*  R - DUP                                             0< IF R +  R> 2* 1-  ELSE R> 2* 3 + THEN LOOP ;                                                                 : 2SBIT   >R D2* DUP 0< IF  D2* R - R> 1+                                 ELSE  D2* R 2DUP  U< IF DROP R> 1- ELSE - R> 1+                 THEN THEN ;                                                                                                           -->                                                             ( math: SQRT, cont. )                                           : 1SBIT  >R DUP 0< IF 2DROP R> 1+                                        ELSE D2* 32768 R DU< 0= R> + THEN ;                    : SQRT   ( ud1 -- u2 )                                                   0 1 8 EBITS  ROT DROP  6 EBITS  2SBIT  1SBIT ;         : SQRT?  ( n --   ;print square root for n <= 4095 )                     16 *  62500 U* SQRT                                             0 <# # # # 46 HOLD #S #> TYPE SPACE ;                  ;S                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              ( SCRAMBLE )                                                    : SWAP-BASES  ( n1 n2 -- ; swaps bases n1 & n2 )                      BASES SWAP BASES 2DUP   C@ SWAP C@  ( a2 a1 [a1] [a2])          ROT C! SWAP C! ;                                                                                                          : SCRAMBLE  ( frag. -- ; scramble bases of frag )                     DUP .BASES + @ SWAP .LENGTH + @  2DUP OVER +  ( i l i f )       SWAP DO                                                              DUP RANDOM 3 PICK +  ( choose random position )                 I SWAP-BASES                                                    LOOP DROP DROP ;